COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 $Header: DEFSYS.LISP_V 2.1 87/05/23 14:56:18 doug Exp $
C00026 ENDMK
C⊗;
;;; $Header: DEFSYS.LISP_V 2.1 87/05/23 14:56:18 doug Exp $
;;;
;;; A portable defsystem facility written in pure Common LISP.
;;;
;;; Copyright (c) 1987, Prime Computer, Inc., Natick, MA 01760
;;;                     All Rights Reserved
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Prime Computer Inc. makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;
;;; dougr@eddie.mit.edu -or- doug@enx.prime.com
;;;
;;;
;;; $Log:    DEFSYS.LISP_V $
;;; Revision 2.1  87/05/23  14:56:18  doug
;;; Replaced use of concatenate with make-pathname to produce a more portable
;;; pathname generator.  Also added some declarations to quiet compiler error
;;; messages.
;;;
;;; Revision 2.0  87/05/04  10:52:32  doug
;;; First public version.
;;;
;;; Revision 1.6  87/05/01  16:23:49  doug
;;; Removed documentation to defsystem.mss,doc,quic
;;; Added :load-after dependencies.
;;; More error checking.  Separate package for defsystem and co.
;;;
;;; Revision 1.1  87/04/25  13:00:09  doug
;;; Initial Revision
;;;
;;; Contains definitions for defsystem, undefsystem, load-system,
;;; compile-system and show-system.  See defsystem.doc for more
;;; information.
;;;

(in-package '#:defsystem)

(export '(defsystem load-system compile-system show-system *suffixes*
          *all-systems* undefsystem *defsystem-version* *defsystem-header*))

(defvar *suffixes*
   #+Symbolics                         '("lisp"  . "bin")
   #+(and dec common vax (not ultrix)) '("LSP"   . "FAS")
   #+(and dec common vax ultrix)       '("lsp"   . "fas")
   #+KCL                               '("lsp"   . "o")
   #+Xerox                             '("lisp"  . "dfasl")
   #+(and Lucid MC68000)               '("lisp"  . "lbin")
   #+(and Lucid VAX VMS)               '("lisp"  . "vbin")
   #+excl                              '("cl"    . "fasl")
   #+system::cmu                       '("slisp" . "sfasl")
   #+PRIME                             '("lisp" . "pbin")
   #+HP                                '("l"     . "b")
   #+TI                                '("lisp"  . "xfasl"))

(defvar *defsystem-version* "$Revision: 2.1 $")
(defvar *defsystem-header* "$Header: DEFSYS.LISP_V 2.1 87/05/23 14:56:18 doug Exp $")

(defstruct (system (:print-function print-system))
  (name "")
  (default-pathname (pathname "") :type pathname)
  (default-package nil :type symbol)
  (needed-systems nil :type list)
  (load-before-compile nil :type list)
  (module-list nil :type list)
  (needs-update nil)
  (modules (make-hash-table)))

(defun print-system (system stream level)
  (declare (ignore level))
  (format stream "#<System ~A>" (system-name system)))

(defstruct (module (:print-function print-module))
  (name "")
  (load-before-compile nil)
  (compile-satisfies-load nil)
  (load-after nil)
  (recompile-on nil)
  (pathname nil)
  (dtm 0)
  (package nil)
  (in-process nil)
  (loaded nil)
  )

(defun print-module (module stream level)
  (declare (ignore level))
  (format stream "#<Module ~A>" (module-name module)))

(defvar *all-systems* nil)
(defvar *loaded-systems* nil)

(defmacro undefsystem (system-name)
  `(setq *all-systems* (remove-if #'(lambda (x) (eql (car x) ',system-name))
                         *all-systems*)))

(defmacro defsystem (system-name options &body modules)
  `(let ((system-construct (append '(:name ,system-name) ',options))
         mod-list
         )
     (let ((system (apply #'make-system system-construct)))
       (when (assoc ',system-name *all-systems*)
         (setq *all-systems* (remove-if #'(lambda (x) (eql (car x) ',system-name))
                               *all-systems*)))
       (push (cons ',system-name system) *all-systems*)
       (let ((system-mods (system-modules system)))
         (dolist (module ',modules)
           (let ((mod-construct (cons ':name module)))
             (if (symbolp module)
               (setq mod-construct (list ':name module)))
             (let ((module-structure (apply #'make-module mod-construct)))
               (push (module-name module-structure) mod-list)
               (setf (gethash (module-name module-structure) system-mods)
                     module-structure)
               ))
           )
         )
       (setf (system-module-list system) (reverse mod-list))
       )
     ',system-name
     )
  )

(defun load-system (system-name &key reload (include-components T)
                     &aux system-entry system *load-verbose*)
  (declare (special *load-verbose*))
  (setq system-entry (assoc system-name *all-systems*))
  (setq *load-verbose* nil)
  (unless system-entry
    (error "No such system description loaded.  System ~S"
      system-name))
  (setq system (cdr system-entry))
  ;; Load subsystems
  (when include-components
    (dolist (subsystem (system-needed-systems system))
      (when (or reload (not (member subsystem *loaded-systems*)))
        (format T ";;; Loading System ~S~%" subsystem)
        (load-system subsystem :reload reload
          :include-components include-components))))
  ;; Load modules
  (dolist (module (system-module-list system))
    (let ((module-description (getmod module system)))
      ;; If already loaded then only reload if needed
      (load-if-needed module-description system reload)
      )
    )
  (format T ";;; Done loading system ~S~%" system-name)
  (setf (system-needs-update system) nil)
  (unless (member system-name *loaded-systems*)
     (push system-name *loaded-systems*))
  )

(defun compile-system (system-name &key reload recompile (include-components T)
                        &aux system-entry system
                        compiled-modules *load-verbose*)
  (declare (special system compiled-modules *load-verbose*))
  (setq *load-verbose* nil)
  (setq system-entry (assoc system-name *all-systems*))
  (unless system-entry
    (error "No such system description loaded.  System ~S"
      system-name))
  (setq system (cdr system-entry))
  ;; Recompile included systems
  (when include-components
    (dolist (subsystem (system-needed-systems system))
      (format T ";;; Compiling System ~S~%" subsystem)
      (compile-system subsystem
        :recompile recompile
        :include-components include-components))
    )
  ;; Load Compile subsystem dependencies
  (dolist (subsystem (system-load-before-compile system))
    (when (or reload
              (not (member subsystem *loaded-systems*))
              (system-needs-update subsystem))
      (format T ";;; Loading System ~S~%" subsystem)
      (load-system subsystem
        :reload reload
        :include-components include-components)))
  ;; Compile modules
  (dolist (module (system-module-list system))
    (compile-if-needed module reload recompile)
    )
  nil
  )

(defun get-pathname (module system &aux mpath sname bname sdtm bdtm)
  (unless (setq mpath (module-pathname module))
    (setq mpath
          (setf (module-pathname module)
                (make-pathname :directory (pathname-directory
                                            (system-default-pathname system))
                  :name (string (module-name module))))))
  (setq sname (make-pathname :directory (pathname-directory mpath)
                :name (pathname-name mpath)
                :type (car *suffixes*)))
  (setq bname (make-pathname :directory (pathname-directory mpath)
                :name (pathname-name mpath)
                :type (cdr *suffixes*)))
  (setq sdtm (file-write-date sname)
        bdtm (file-write-date bname))
  (cond
    ((and sdtm bdtm)                   ; Both exist take newer
     (if (> sdtm bdtm)
       sname
       bname))
    (bdtm bname)
    (sdtm sname)
    (T                                 ; no file around
      (error "Can't find any file for module named ~S"
        (module-name module))))
  )

(defun load-if-needed (module-description system &optional reload &aux path)
  (setq path (get-pathname module-description system))
  (if (and (module-loaded module-description) (not reload))
    (when (< (module-dtm module-description)
            (file-write-date path))
      (do-load system module-description path reload)
      (setf (module-dtm module-description)
            (file-write-date path))
      )
    (progn (do-load system module-description path reload)
           (unless (module-pathname module-description)
             (setf (module-pathname module-description)
                   (make-pathname :directory (pathname-directory
                                               (system-default-pathname system))
                     :name (module-name module-description)))
             )
           (setf (module-dtm module-description)
                 (file-write-date path))
           (setf (module-loaded module-description) T)
      )
    )
  )

(defun do-load (system module path &optional reload &aux package load-after)
  (when (setq load-after (module-load-after module))
    (when (symbolp load-after) (setq load-after (list load-after)))
    (dolist (m load-after)
      (load-if-needed
        (getmod m system)
        system
        reload
        ))
      )
  (format T ";;; Loading file ~S~%" path)
  (setq package (or (module-package module)
                    (system-default-package system)))
  (if package
    (let ((spackage *package*))
      (unwind-protect
          (progn (in-package package)
                 (load path))
        (in-package (package-name spackage))))
    (load path))
  )

(defun compile-if-needed (module-name
                           &optional reload recompile
                           &aux mpath sname bname module
                           sdtm bdtm ddtm ddtms package)
  (declare (special system compiled-modules))
  (setq module (getmod module-name system))
  (setq package (or (module-package module)
                    (system-default-package system)))
  ;; Do our dependents
  (if (or (null (module-recompile-on module))
          (module-in-process module))
    (setq ddtms '(0))
    (unwind-protect
      ;; We don't want to recurse infinitely if one module has
      ;; a reciprocal compile relation with another so we set the
      ;; in-process flag to cause this to bottom out.  The
      ;; unwind-protect makes sure it's cleaned up on error cases.
        (progn (setf (module-in-process module) T)
               (dolist (mod (module-recompile-on module))
                 (push (compile-if-needed mod) ddtms)
                 ))
      (setf (module-in-process module) nil)
      )
    )
  (setq ddtm (apply #'max ddtms))
  (unless (setq mpath (module-pathname module))
    (setq mpath
          (setf (module-pathname module)
                (make-pathname :directory (pathname-directory
                                            (system-default-pathname system))
                  :name (string module-name)))))
  (setq sname (make-pathname :directory (pathname-directory mpath)
                :name (pathname-name mpath)
                :type (car *suffixes*)))
  (setq bname (make-pathname :directory (pathname-directory mpath)
                :name (pathname-name mpath)
                :type (cdr *suffixes*)))
  (setq sdtm (file-write-date sname)
        bdtm (file-write-date bname))
  (unless bdtm (setq bdtm 0))
  (unless sdtm
    (error "Can't find the source file for ~S~%" module-name))
  (if (and (or (< bdtm sdtm) (< bdtm ddtm)
               (and recompile (not (member module-name compiled-modules))))
           (not (module-in-process module)))
    ;; Recompiling.. load necessary files
    (progn
      (dolist (name (module-recompile-on module))
        (load-if-needed (getmod name system) system reload)
        )
      (dolist (name (module-load-before-compile module))
        (load-if-needed (getmod name system) system reload)
        )
      (format T ";;; Compiling ~S..." (module-name module))
      (if package
        (let ((spackage *package*))
          (unwind-protect
              (progn (in-package package)
                     (compile-file sname))
            (in-package (package-name spackage))))
        (compile-file sname))
      (when (module-compile-satisfies-load module)
            (setf (module-loaded module) T))
      (format T "~%")
      (push module-name compiled-modules)
      (setf (system-needs-update system) T)
      ;; recompiling produces a new file so...
      (get-universal-time)
      )
    ;; Not recompiling or in process..
    (max bdtm sdtm))
  )

(defun show-system (system-name &aux system system-entry)
  (setq system-entry (assoc system-name *all-systems*))
  (unless system-entry
    (error "No such system description loaded.  System ~S"
      system-name))
  (setq system (cdr system-entry))
  (format T ";;; System: ~S~%;;;~%" (system-name system))
  (format T ";;; Needed Systems: ~S~%" (system-needed-systems system))
  (format T ";;; Default Package: ~S~%" (system-default-package system))
  (format T ";;; Default Pathname: ~S~%" (system-default-pathname system))
  (format T ";;; Load-before-compile: ~S~%" (system-load-before-compile system))
  (format T ";;; Needs update: ~S~%" (system-needs-update system))
  (format T ";;;~%")
  (dolist (module-name (system-module-list system))
    (let ((module (getmod module-name  system)))
      (format T ";;; Module: ~S  Package: ~S  Loaded: ~S  Compile-satisfies-load: ~S~%"
        module-name (module-package module)
        (module-loaded module) (module-compile-satisfies-load module)
        )
      (format T ";;;    Load-before-compile: ~S ~%"
        (module-load-before-compile module))
      (format T ";;;    Load-after: ~S~%"
        (module-load-after module))
      (format T ";;;    Recompile-on: ~S~%" (module-recompile-on module))
      (format T ";;;    Pathname: ~S~%" (module-pathname module))
      )
    )
  (format T ";;; ---------------------------------")
  )

(defun getmod (m s &aux md)
  (setq md (gethash m (system-modules s)))
  (if md
    md
    (error "Module ~S not present in System ~S~%"
      m s)
    ))